;;########################################################################
;; mmrmob.lsp
;; multivariate multiple regression ViSta model object
;; Copyright (c) 1991-99 by Forrest W. Young
;;########################################################################

(require "vista")

;;---------------------------------------------------------------------------
;;constructor function for multivariate multiple regression model object
;;----------------------------------------------------------------------------

(let ((menu-item-title "Multivariate Regression")
      (tool-name "MulReg")
      (model-prefix "MRG")
      (ok-data-types '("bivariate" "multivariate" "crosstabs" "general"))
      (ok-variable-types '(numeric)))

  (defun multivariate-regression 
    (&key 
     (responses nil)
     (predictors nil)
     (weight nil)
     (intercept t)
     (redundancy nil)
     (data *current-data*)  
     (title menu-item-title)
     (name nil)
     (dialog nil) )
"ViSta function to perform Multivariate Regression analysis by ordinary least squares.  
With no arguments the current data are analyzed, with the first active numeric variable as the response, and the remaining active numeric variables as the predictors. Keyword arguments are
:RESPONSES followed by a list of the response variables. If there is more than one response variable then several separate multiple regressions are performed, each with the same predictors. These are then followed by a multivariate analysis predicting all responses simultaneously;
:PREDICTORS followed by a list of the predictor variables;
:WEIGHT followed by a variable name (nil by default);
:INTERCEPT followed by t if an intercept is to be computed (default) or nil;
:REDUNDANCY followed by a value specifying the number of redundancy variables  to be computed or nil if they are not to be computed (default);
:DATA   followed by the data-object to be analyzed (default: current-data);
:TITLE  followed by a character string (default: Multivariate Regression);
:DIALOG followed by t (to display parameters dialog box) or nil (default)."
    (if (not (eq *current-data* data)) (setcd data))
    (if (not name) (setf name (strcat model-prefix "-" (send *current-data* :name))))
    (cond 
      ((or (= 1 (send current-data :active-nvar '(numeric)))
           (> 4 (send current-data :active-nobs)))
       (error-message (format nil "For Regression Analysis there must be four or more active observations and two or more active numeric variables."))
       (send *toolbox* :reset-button tool-name))
      (t
       (send mmr-model-object-proto 
             :new responses predictors weight intercept redundancy 
             menu-item-title tool-name model-prefix ok-data-types 
             data title name dialog ok-variable-types)
       )))
  )

;;---------------------------------------------------------------------------
;;define multivariate multiple regression model object
;;----------------------------------------------------------------------------

(defproto mmr-model-object-proto 
  '(reg-models num-iv num-dv iv dv y-stdv x-stdv intercept predictors 
    responses weights scores coefs beta redundancy redun-index redun-evals 
    redun-evecs redun-scores redun-coefs redun-bmat cor cov) () 
  analysis-plugin-object-proto)

(defmeth mmr-model-object-proto :isnew 
  (responses predictors weight intercept redundancy 
             menu-item-title tool-name model-prefix ok-data-types 
             data title name dialog ok-variable-types)
  (when (not dialog) 
        (when (not responses)
              (setf responses (list (first 
                      (send current-data :active-variables '(numeric))))))
        (when (not predictors)
              (setf predictors 
                    (rest (send current-data :active-variables '(numeric)))))
        (send self :responses responses)
        (send self :predictors predictors)
        (send self :check-vars (send self :responses) (send self :predictors))
        (send self :intercept intercept)
        (send self :weights weight)
        (when (not redundancy) (setf redundancy 0))
        (send self :redundancy redundancy))
  (send self :model-abbrev model-prefix )
  
  (call-next-method 
   ;number data title name dialog
   menu-item-title tool-name model-prefix ok-data-types 
   data title name dialog ok-variable-types)
  )

(defmeth mmr-model-object-proto :reg-models (&optional (names nil set))
    (if set (setf (slot-value 'reg-models) names))
    (slot-value 'reg-models))

(defmeth mmr-model-object-proto :num-iv (&optional (names nil set))
    (if set (setf (slot-value 'num-iv) names))
    (slot-value 'num-iv))

(defmeth mmr-model-object-proto :num-dv (&optional (names nil set))
    (if set (setf (slot-value 'num-dv) names))
    (slot-value 'num-dv))

(defmeth mmr-model-object-proto :iv (&optional (numbers nil set))
    (if set (setf (slot-value 'iv) numbers))
    (slot-value 'iv))

(defmeth mmr-model-object-proto :dv (&optional (numbers nil set))
    (if set (setf (slot-value 'dv) numbers))
    (slot-value 'dv))

(defmeth mmr-model-object-proto :x-stdv (&optional (numbers nil set))
    (if set (setf (slot-value 'x-stdv) numbers))
    (slot-value 'x-stdv))

(defmeth mmr-model-object-proto :y-stdv (&optional (numbers nil set))
    (if set (setf (slot-value 'y-stdv) numbers))
    (slot-value 'y-stdv))

(defmeth mmr-model-object-proto :predictors (&optional (names nil set))
    (if set (setf (slot-value 'predictors) names))
    (slot-value 'predictors))

(defmeth mmr-model-object-proto :responses (&optional (names nil set))
    (if set (setf (slot-value 'responses) names))
    (slot-value 'responses))

(defmeth mmr-model-object-proto :intercept (&optional (val nil set))
    (if set (setf (slot-value 'intercept) val))
    (slot-value 'intercept))

(defmeth mmr-model-object-proto :beta (&optional (numbers nil set))
    (if set (setf (slot-value 'beta) numbers))
    (slot-value 'beta))

(defmeth mmr-model-object-proto :redundancy (&optional (val nil set))
    (if set (setf (slot-value 'redundancy) val))
    (slot-value 'redundancy))

(defmeth mmr-model-object-proto :weights (&optional (val nil set))
    (if set (setf (slot-value 'weights) val))
    (slot-value 'weights))

(defmeth mmr-model-object-proto :scores (&optional (names nil set))
  (if set (setf (slot-value 'scores) names))
  (slot-value 'scores))

(defmeth mmr-model-object-proto :coefs (&optional (names nil set))
    (if set (setf (slot-value 'coefs) names))
    (slot-value 'coefs))

(defmeth mmr-model-object-proto :redun-index (&optional (value nil set))
    (if set (setf (slot-value 'redun-index) value))
    (slot-value 'redun-index))

(defmeth mmr-model-object-proto :redun-evals (&optional (vector nil set))
    (if set (setf (slot-value 'redun-evals) vector))
    (slot-value 'redun-evals))

(defmeth mmr-model-object-proto :redun-evecs (&optional (matrix nil set))
    (if set (setf (slot-value 'redun-evecs) matrix))
    (slot-value 'redun-evecs))

(defmeth mmr-model-object-proto :redun-scores (&optional (matrix nil set))
  (if set (setf (slot-value 'redun-scores) matrix))
  (slot-value 'redun-scores))

(defmeth mmr-model-object-proto :redun-coefs (&optional (matrix nil set))
    (if set (setf (slot-value 'redun-coefs) matrix))
    (slot-value 'redun-coefs))

(defmeth mmr-model-object-proto :redun-bmat (&optional (matrix nil set))
    (if set (setf (slot-value 'redun-bmat) matrix))
    (slot-value 'redun-bmat))

(defmeth mmr-model-object-proto :cor (&optional (matrix nil set))
    (if set (setf (slot-value 'cor) matrix))
    (slot-value 'cor))

(defmeth mmr-model-object-proto :cov (&optional (matrix nil set))
    (if set (setf (slot-value 'cov) matrix))
    (slot-value 'cov))

(defmeth mmr-model-object-proto :check-vars (responses predictors)
  (let ((vars (copy-list (send current-data :variables)))
        )
    (dotimes (i (length vars))
             (setf (select vars i) (string-downcase (select vars i))))
    (dotimes (i (length responses))

             (when (not (member (string-downcase (select responses i)) 
                                vars :test #'equal))
                   (error-message "Bad Response Variable List.")))
    (dotimes (i (length predictors))
             (when (not (member (string-downcase (select predictors i)) 
                                vars :test #'equal))
                   (error-message "Bad Predictor Variable List.")))))

(defmeth mmr-model-object-proto :create-data 
  (&key (dialog nil)
        (scores t)
        (coefs  t)
        (input  nil))
  (if (not (eq current-object self)) (setcm self)) 
  (let ((creator (send *desktop* :selected-icon))
        (desires (list (list (if input 0) (if scores 1) (if coefs 2) )))
        )
    (if dialog
        (setf desires
              (if (send self :redundancy) 
                  (choose-subset-dialog "Choose Desired Data Objects"
                               '("Analyzed Input Data"
                                 "Predicted Values (Scores)" 
                                 "Regression Coefficients"
                                 "Redundancy Scores"
                                 "Redundancy Coefficients"
                                 "Redundancy Variates"
                                        )
                                       :initial (select desires 0))
                  (choose-subset-dialog "Choose Desired Data Objects"
                               '("Analyzed Input Data"
                                 "Predicted Values (Scores)" 
                                 "Regression Coefficients"      
                                           )
                                       :initial (select desires 0)))))
    (when desires
          (when (member '0 (select desires 0))
                (send self :create-input-data-object "MRG" creator))
          (when (member '1 (select desires 0))
                (send self :mmr-scores-data-object creator))
          (when (member '2 (select desires 0))
                (send self :mmr-coefs-data-object creator))
          (when (member '3 (select desires 0))
                (send self :red-scores-data-object creator))
          (when (member '4 (select desires 0))
                (send self :red-reg-coefs-data-object creator))
          (when (member '5 (select desires 0))
                (send self :red-var-coefs-data-object creator))
          
          )
    t))
 

(defmeth mmr-model-object-proto :mmr-scores-data-object (creator)
  (let ((n (send self :num-dv)))
  (data (concatenate 'string "RegScores-" (send self :name))
   :created creator
   :creator-object self
   :title (concatenate 'string "MulReg Scores for " 
                       (send self :title))
   :data (combine (send self :scores))
   :variables (mapcar #'concatenate (repeat 'string n) (select (send self :variables) (send self :dv)) (repeat "-hat" n))
   :labels (send self :labels)
   :types (select (send self :types) (send self :dv)))
  ))


(defmeth mmr-model-object-proto :red-scores-data-object (creator)
  (let ((n (send self :num-dv)))
  (data (concatenate 'string "RedScores-" (send self :name))
   :created creator
   :creator-object self
   :title (concatenate 'string "Redundancy Scores for " 
                       (send self :title))
   :data (combine (send self :redun-scores))
   :variables (mapcar #'concatenate (repeat 'string n) (select (send self :variables) (send self :dv)) (repeat "-hat" n))
   :labels (send self :labels)
   :types (select (send self :types) (send self :dv)))
  ))


(defmeth mmr-model-object-proto :mmr-coefs-data-object (creator)
  (data (concatenate 'string "RegCoefs-" (send self :name))
   :created creator
   :creator-object self
   :title (concatenate 'string "Regression Coefficients for " 
                       (send self :title))
   :data (combine (transpose (send self :coefs)))
   :labels (select (send self :variables) (send self :iv))
   :variables (select (send self :variables) (send self :dv))
  ))

(defmeth mmr-model-object-proto :red-reg-coefs-data-object (creator)
  (data (concatenate 'string "RedRegCoefs-" (send self :name))
   :created creator
   :creator-object self
   :title (concatenate 'string "Redundancy Coefficients for " 
                       (send self :title))
   :data (combine (send self :redun-bmat))
   :labels (select (send self :variables) (send self :iv))
   :variables (select (send self :variables) (send self :dv))
  ))

(defmeth mmr-model-object-proto :red-var-coefs-data-object (creator)
  (let* ((nredun (send self :redundancy))
         (redvars (mapcar #'(lambda (x) (format nil "Red~d" x))
                            (iseq nredun))))
    (data (concatenate 'string "RedVarCoefs-" (send self :name))
          :created creator
          :creator-object self
          :title (concatenate 'string "Redundancy Variable Coefficients for " 
                              (send self :title))
          :data (combine (select (send self :redun-coefs)
                                 (iseq (send self :num-iv)) (iseq nredun))) 
          :variables redvars
          :labels (select (send self :variables) (send self :iv))
          )))

(defmeth mmr-model-object-proto :save-model-template (data-object)
"Args: (data-object)
DATA-OBJECT is the object-identification information of a data object. 
The method contains a template for saving the model-object."
  `(multivariate-regression    
    :title       ,(send self :title)
    :name        ,(send self :name) 
    :dialog       nil
    :responses  ',(send self :responses)
    :predictors ',(send self :predictors)
    :intercept    t
    :data (data  ,(send data-object :name)
                 :title      ,(send data-object :title)
                 :variables ',(send self :variables)
                 :types     ',(send self :types)
                 :labels    ',(send self :labels)
                 :data      ',(send self :data))))

(defmeth mmr-model-object-proto :report (&key (dialog nil)) 
  (if (not (eq current-object self)) (setcm self))
  (let* ((labels (send self :labels))
         (dvars  (select (send self :variables) 
                         (send self :dv)))
         (ivars  (select (send self :variables) 
                         (send self :iv)))
         
         (scores (send self :scores))
         (coefs  (send self :coefs ))
         (lc-names (mapcar #'(lambda (x) (format nil "MulReg~a" x)) ;?????
                      (iseq (send self :nvar))))
         (mtest  (if (and (> (send self :num-dv) 1)
                          (> (send self :nobs) 
                             (sum (send self :num-dv) (send self :num-iv)))) 
                     (send self :multivariate-test)
                     nil))
         (redun  (send self :redundancy))
         (y-stdv (send self :y-stdv))
         (x-stdv (send self :x-stdv))
         (beta   (send self :beta))
         (w nil)
         (desires (list '(0)))
         )
    (when dialog 
          (setf desires
                (choose-subset-dialog "Choose Optional Reports:"
                               '("Univariate Analyses"
                                 "Correlation Matrix" 
                                 "Covariance Matrix")
                                      :initial '(0))))
    (when (and (not (equalp desires nil))
               (> (length dvars) 1))
    (setf w (report-header (send self :title)))
    (display-string (format nil "Multivariate Multiple Regression Analysis~%") w)
    (display-string (format nil "~%Model: ~a~%" 
                            (send self :name )) w)
    (display-string (format nil "Response  Variables:   ~a~%" dvars)   w)
    (display-string (format nil "Predictor Variables:   ~a~%" ivars)   w)
    (display-string (format nil "Number of Observatios: ~d~%"
                            (send self :nobs)) w)
    (display-string (format nil "Redundancy analysis~a requested.~2%"
                            (if redun "" " not")) w));fwy
    (when (member '0 (select desires 0))
          (let ((wuni (report-header "Univariate Regression Report")))
            (dotimes (i (length dvars))
               (display-string (format nil "Univariate Regression Report~%") wuni)
               (display-string 
                (format nil "~%Model: ~a~%" 
                        (send self :name )) wuni)
               (display-string 
                (format nil "Response  Variable:    ~a~%" 
                        (select dvars i))   wuni)
               (display-string 
                (format nil "Predictor Variables:  ~a~%" ivars)   wuni)
               (display-string 
                (format nil "Number of Observatios: ~d~%"
                        (send self :nobs)) wuni)
               (send (select (send self :reg-models) i) :display wuni)
               (display-string (format nil "~2%") wuni))
            (send wuni :fit-window-to-text)
            ))
    (when (= (send self :num-dv) 1)
          (help (format nil "You have used the Multivariate Multiple Regression procedure for Univariate Multiple Regression.  More complete univariate results are provided by Regres, the Univariate Multiple Regression procedure.")))
    (when (> (send self :num-dv) 1)
         ; (display-string (format nil "------------------------------~%") w)
          ;(display-string (format nil "~%MULTIVARIATE REGRESSION ANALYSIS") w)
          (when (member '1 (select desires 0))     
                (display-string (format nil "~2%Correlation Matrix~%") w)
                (print-matrix-to-window (send self :cor) w 
                                        :labels (combine dvars ivars)))
          (when (member '2 (select desires 0))           
                (display-string (format nil "~%Covariance Matrix~%") w)
                (print-matrix-to-window (send self :cov) w
                                        :labels (combine dvars ivars)))
    (when mtest
     (when (select mtest 6)
      (display-string
        (format nil "~%Multivariate Test: ~%Ho: No relationship between responses and predictors") w)
      (display-string
        (format nil "~%Wilks' Lambda = ~1,7f  F(~3,2f, ~3,2f) = ~3,2f  p = ~1,4f" (first mtest) (third mtest) (fourth mtest) (second mtest) (fifth mtest)) w)
      (if (select mtest 5)
        (display-string (format nil "~%F-statistic is exact.~%") w)
        (display-string (format nil "~%F-statistic is approximate.~%") w)))
     (when (not (select mtest 6))
      (display-string
       (format nil "Multivariate test not reported. Matrix of response variables is too close to singularity.~%") w)))
    (when (not mtest)
          (display-string (format nil "~%Multivariate test not calculated.") w)
          (when (> (sum (send self :num-dv) (send self :num-iv)) 
                   (send self :nobs))
                (display-string (format nil " (There are more variables than observations.)") w)) )
    (display-string (format nil "~%Response  Variable Standard Deviations~%~a" 
                            (fuzz y-stdv 4)) w)
    (display-string (format nil "~%Predictor Variable Standard Deviations~%~a" 
                            (fuzz x-stdv 4)) w)
    
    (display-string 
     (format nil "~2%Raw Regression (B) Coefficients~%") w)
    (print-matrix-to-window (transpose coefs) w :labels ivars)
    (display-string
     (format nil "~%Standardized Regression (Beta) Coefficients~%") w)  
    (print-matrix-to-window beta w :labels ivars)
    (display-string 
     (format nil "~%Regression Scores (Predicted/Fitted Values):~%") w)
    (print-matrix-to-window scores w :labels labels)
    (when redun
     (display-string (format nil "~%------------------------------~%") w)
     (display-string (format nil "~%REDUNDANCY ANALYSIS") w)
     (display-string (format nil "~%Using ~d Redundancy Variates" redun) w)     
     (display-string (format nil "~%Eigenvectors~%") w)
     (print-matrix-to-window (send self :redun-evecs) w :labels dvars)
     (display-string (format nil "~%Eigenvalues  = ~a" 
                     (combine (fuzz (send current-model :redun-evals) 4))) w)
     (display-string (format nil "~%Proportions  = ~a"
                  (combine (fuzz (/ (send current-model :redun-evals)
                                    (sum (send current-model :redun-evals)))
                                 4))) w)
     (display-string (format nil "~%Redundancies = ~a"
                     (combine (fuzz
                     (/ (send self :redun-evals) (send self :num-iv)) 4))) w)
     (display-string (format nil "~%Redundancy   = ~7,4f (total)" 
                             (send self :redun-index)) w)
     (display-string (format nil "~%Redundancy   = ~7,4f (for ~d variates)"
              (sum (select (/ (send self :redun-evals) (send self :num-dv))
                           (iseq (send self :redundancy))))
         (send self :redundancy)) w)                                                               
     (display-string (format nil "~2%Redundancy Variate Coefficients~%") w)
     (print-matrix-to-window (send self :redun-coefs) w :labels ivars)
     (display-string (format nil "~%Raw Redundancy Regression Coefficients~%(Using the first ~d Redundancy Variates)~%"redun) w)
     (print-matrix-to-window (send self :redun-bmat) w :labels ivars)
     (display-string (format nil "~%Standardized Redundancy Regression Coefficients~%(Using the first ~d Redundancy Variates)~%"redun) w)
     (print-matrix-to-window 
      (matmult (diagonal x-stdv) 
               (send self :redun-bmat) 
               (inverse (diagonal y-stdv))) w :labels ivars)
     (display-string 
     (format nil "~%Redundancy Scores (Predicted/Fitted Values)~%(Using the first ~d Redundancy Variates)~%"redun) w)
    (print-matrix-to-window (send self :redun-scores) w :labels labels)
    (when w (send w :show-window)))
    (send w :fit-window-to-text)
    w)))
  
(provide "mmrmob1")
(load (strcat *mmr-plugin-path* "mmrmob2"))
(load (strcat *mmr-plugin-path* "mmrmob3"))
(load (strcat *mmr-plugin-path* "mmrvis1"))
(load (strcat *mmr-plugin-path* "mmrvis2"))